unit uSBDUnit_TestCaseNodeImpl;
interface
uses uSBDUnit_TestNodeImpl, Classes, uSBDUnit_TestNode_InternalSupport,
     uSBDUnit_Model, uSBD_BaseTypes, uSBD_ServiceProvider,
     uSBDUnit_TestScheduler, uSBDUnit_Types, SysUtils, Rtti;

type

RTestPoint = record // Test status and results for a setup/main/teardown phase
                    //  of one run of one test case.
  Status: uSBDUnit_TestScheduler.TNodeStatus;
  ExecutionResult: TExecutionResult;
  procedure Clear;
  end;

RCaseRun = record  // Container and summary results for one run of one test case.
  FRunResult: TExecutionResult;
  FPoints: array[TTestPointPhase] of RTestPoint;
  procedure Clear;
  function  ComputeRunResult: TExecutionResult;
  procedure SkipIfNotDone;
  end;


TAutoFailReason = (reasonUserException, reasonFailMethod, reasonLeakage, reasonTimeOut, reasonHang);

TTestCaseNode = class sealed( TTestNode, ITestCaseEx, ITestCaseNode, ITestPoint)
  private
    FParentSuite: ITestSuiteNodeEx;
    [Injection('Mastered')] FHarness: ITestHarness;
    [Injection('Buffered')] FThreadedHarness: ITestHarness;
    FHarnessToUse: ITestHarness;
    FMethod: integer;
    FRuns: TArray<RCaseRun>; // Container and summary results for all the repeated runs of one test case.
    FRunCursor: RTestPointCursorMemento;
    FdoInbackground: boolean;
    FTimeOut: integer;
    FNobs: RModulationNobsToTweek;

    procedure SetMethodIndex( MethodIdx: integer);
    function  GetFailMessage: string;
    function  GetFailStamp: TDateTime;
    function  GetNonFailMessages: TNonFailMessageArray;

    function  GetStatus_Point: uSBDUnit_TestScheduler.TNodeStatus;
    function  ITestPoint.GetStatus = GetStatus_Point;
    procedure SetStatus_Point( Value: uSBDUnit_TestScheduler.TNodeStatus);
    procedure ITestPoint.SetStatus = SetStatus_Point;
    function  GetExecResult_Point: TExecutionResult;
    function  ITestPoint.GetExecResult = GetExecResult_Point;
    procedure SetExecResult_Point( Value: TExecutionResult);
    procedure ITestPoint.SetExecResult = SetExecResult_Point;

    procedure PreExecute;
    function  Execute: boolean;
    procedure PostExecute( isTimedOut: boolean);

    function  TimeOut: integer;
    function  doInbackground: boolean;
    procedure ClearRuns;
    function  ComputeOverAllRunsResult: TExecutionResult;

    procedure InvokePhase( InvocationPhase: TTestPointPhase);
    procedure AbsorbHarness;

    procedure AutoFail( Reason: TAutoFailReason; InvocationPhase: TTestPointPhase; E: Exception);
    function  CursorOutOfBounds: boolean;
    procedure SetCursorMemento( const Memento: RTestPointCursorMemento);
    function  GetRunCount: integer;
    function  RttiMethod( var NewContext: TRttiContext): TRttiMethod;
    procedure TriggerModulationEvent( Events: TTestModulationEventSet);
    procedure ActuateNobs;

  protected
    function  ITestCaseEx.GetExecResult = GetExecResult_Overall;
    function  ITestCaseNode.GetExecResult = GetExecResult_Overall;
    procedure Clear;                                 override;
    procedure ShutDown;                              override;
    class function  ExceptionClass: TSBDUnit_ExceptionClass;  override;
    function  IntrinsicFailCount      : integer;     override;
    function  InstrinsicExecutionCount: integer;     override;
    function  IntrinsicLoadCount      : integer;     override;
    procedure SetParentNodeAsIntf( const Value: IInterface);    override;

  public
    [Configuration('nkTestCase')] constructor ServiceModeCreate; override;
  end;


TNonFailMessage = class sealed( TSBD_RefCountedCommonBase, INonFailMessage, INonFailMessageEx)
  private
    FKind: TNonFailMessageKind;
    FStamp: TDateTime;
    FMsg: string;
    function Kind: TNonFailMessageKind;
    function Stamp: TDateTime;
    function Msg: string;
    procedure SetNonFailMessage( Stamp1: TDateTime; const Msg1: string);
  protected
    class function  ExceptionClass: TSBDUnit_ExceptionClass;     override;
  public
    [Configuration('Warning')] constructor CreateWarning;
    [Configuration('Info'   )] constructor CreateInfo;
  end;


TSBDUnit_TestCaseException = class( TSBDUnit_Exception) end;

resourcestring
  TimeOutErrorMessage = 'Test execution time-out.';
  HangOutErrorMessage = 'Test case hung.';
  LeakageErrorMessage = 'Memory leakage detected.';

procedure RegisterServices( const Registrar: IServiceProvider);
// ^-- Registers (ITestNode,'nkTestCase')
// ^-- Registers (INonFailMessage,'Info'&'Warning')

implementation









uses TypInfo;



procedure RegisterServices( const Registrar: IServiceProvider);
begin
TTestCaseNode  .RegisterThis( Registrar, ITestNode); // 'nkTestCase'
TNonFailMessage.RegisterThis( Registrar, INonFailMessage);//  'Info' & 'Warning'
end;


{ TTestCaseNode }

constructor TTestCaseNode.ServiceModeCreate;
var
  Harn: ITestHarnessEx;
begin
FKind := nkTestCase;
inherited ServiceModeCreate;
FNobs.FRepeatCount := 1;
FTimeOut := -1;
if Supports( FHarness, ITestHarnessEx, Harn) and assigned( FParentSuite) then
  Harn.SetTestSuiteClass( FParentSuite.SuiteClass)
end;


procedure TTestCaseNode.Clear;
var
  Harn: ITestHarnessEx;
begin
inherited;
FParentSuite.PowerDownSuite;
ClearRuns;
FRunCursor.ResetCursor;
if Supports( FHarness, ITestHarness, Harn) then
  Harn := nil;
FThreadedHarness := nil;
FHarnessToUse := nil;
end;


procedure TTestCaseNode.ClearRuns;
var
  j: integer;
begin
for j := 0 to Length( FRuns) - 1 do
  FRuns[j].Clear
end;

function TTestCaseNode.ComputeOverAllRunsResult: TExecutionResult;
var
  j, PassCount: integer;
begin
result := erNull;
PassCount := 0;
for j := 0 to Length( FRuns) - 1 do
  case FRuns[j].FRunResult of
    erNull: ;
    erPass: Inc( PassCount);
    erFail: Exit( erFail)
  end;
if PassCount = Length( FRuns) then
  result := erPass
end;

function TTestCaseNode.doInbackground: boolean;
begin
result := FdoInbackground and (FRunCursor.FPhase = phMainExecute)
end;

class function TTestCaseNode.ExceptionClass: TSBDUnit_ExceptionClass;
begin
result := TSBDUnit_TestCaseException
end;

procedure TTestCaseNode.InvokePhase( InvocationPhase: TTestPointPhase);
var
  Suite: ITestSuite;
var
  Context: TRttiContext;
  M: TRttiMethod;
  isLeakageDetected: boolean;
  ModSupport: ITestHarnessExWithTestModulation;

begin
isLeakageDetected := False;
Suite := FParentSuite.GetSuite;
try
  case InvocationPhase of
    phSetup      :  begin
                    TriggerModulationEvent( [evSetup]);
                    SetStatus( sSettingup);
                    Suite.Setup;
                    if GetExecResult_Point <> erFail then
                      SetStatus( sTesting);
                    end;

    phMainExecute:  begin
                    // ***  Potentially executed in-thread.
                    TriggerModulationEvent( [evMainExecute]);
                    M := RttiMethod( Context);
                    try
                      if Supports( FHarnessToUse, ITestHarnessExWithTestModulation, ModSupport) then
                        ModSupport.BeginLeakageSensing( FNobs.FdoLeakageTest and (not doInbackground));
                      M.Invoke( FParentSuite.SuiteObject, []);
                      isLeakageDetected := assigned( ModSupport) and ModSupport.EndLeakageSensing
                    finally
                      if assigned( ModSupport) then
                        ModSupport.EndLeakageSensing;
                      Context.Free
                      end;
                    end;

    phTeardown   :  begin
                    TriggerModulationEvent( [evTeardown]);
                    SetStatus( sTearingDown);
                    Suite.Teardown;
                    end;
    end;
except
  on E: UserFailException do
    AutoFail( reasonFailMethod, InvocationPhase, E);      // ***
  on E: Exception do
    AutoFail( reasonUserException, InvocationPhase, E);   // ***
  end;
if isLeakageDetected then
  AutoFail( reasonLeakage, phMainExecute, nil);
end;


function TTestCaseNode.CursorOutOfBounds: boolean;
begin
result := (FRunCursor.FRunIdx < 0) or (FRunCursor.FRunIdx >= Length( FRuns))
end;

procedure TTestCaseNode.PreExecute;
var
  Harn: ITestHarnessEx;
begin
if CursorOutOfBounds then exit;
if (FRunCursor.FPhase = phMainExecute) and doInbackground then
    begin
    FThreadedHarness := nil;
    AcquireService( ITestHarness, FThreadedHarness, 'Buffered');
    if Supports( FThreadedHarness, ITestHarnessEx, Harn) and assigned( FParentSuite) then
      Harn.SetTestSuiteClass( FParentSuite.SuiteClass);
    FHarnessToUse    := FThreadedHarness
    end
  else
    FHarnessToUse := FHarness; // Mastered.
FParentSuite.GetSuite.SetHarness( FHarnessToUse)
end;

function TTestCaseNode.Execute: boolean;   // ***
begin
// If the setup failed, skip the main and the teardown.
result := False;
if CursorOutOfBounds then exit;
if (FRunCursor.FPhase = phSetup) or
   (GetExecResult_Point <> erFail) then
  InvokePhase( FRunCursor.FPhase);           // ***
result := GetExecResult_Point <> erFail
end;


procedure TTestCaseNode.PostExecute( isTimedOut: boolean);
{$REGION 'Summary of algorithm'}
//1. Absorb the buffered results threaded harness if required.
//2. Test for Hang and mark as fail accordingly.
//3. If Main fails, roll back teardown and mark teardown point as done.
//    Also, if Setup fails, skip Main and TearDown. (done in step 6).
//4. Determine if the run is finalised. Is so, exit here.
//5. Powerdown the suite.
//6. Mark all remaining points as skipped.
//7. Propagate results from point to run
//8. propagate results from run to test case.
//9. Bump fail count and exec count
{$ENDREGION}
var
  OldRunResult , NewRunResult : TExecutionResult;
  OldCaseResult, NewCaseResult: TExecutionResult;
  Changed: boolean;
begin
if CursorOutOfBounds then exit;

// Step 1.
if (FRunCursor.FPhase = phMainExecute) and FdoInbackground and
   assigned( FThreadedHarness) then
  AbsorbHarness;

// Step 2.
if (FRunCursor.FPhase = phMainExecute) and FdoInbackground and isTimedOut then
  AutoFail( reasonHang, phMainExecute, nil);

// Step 3.
with FRuns[ FRunCursor.FRunIdx] do
  if (FRunCursor.FPhase = phMainExecute) and
     (FPoints[phSetup      ].ExecutionResult = erPass) and
     (FPoints[phMainExecute].ExecutionResult = erFail) then
    begin
    FPoints[phTearDown].Status := nsDoing;
    InvokePhase( phTearDown);
    FPoints[phTearDown].Status := nsDone;
    end;

// Step 4. We are finished with the Run if any failure or it's Teardown.
if (FRuns[ FRunCursor.FRunIdx].ComputeRunResult <> erFail) and
   (FRunCursor.FPhase < phTearDown) then exit;

// Step 5.
FParentSuite.PowerDownSuite;

// Step 6. Mark all remaining points within the run as skipped.
FRuns[ FRunCursor.FRunIdx].SkipIfNotDone;

// Step 7. Propagate results from point to run
OldRunResult := FRuns[ FRunCursor.FRunIdx].FRunResult;
NewRunResult := FRuns[ FRunCursor.FRunIdx].ComputeRunResult;
Changed := NewRunResult <> OldRunResult;
if Changed then
  FRuns[ FRunCursor.FRunIdx].FRunResult := NewRunResult;

// Step 8. Propagate results from the run to the test case.
if Changed then
  begin
  NewCaseResult := ComputeOverAllRunsResult;
  OldCaseResult := FExecResult_Overall;
  Changed := NewCaseResult <> OldCaseResult;
  end;
if Changed then
  SetTestResult_Overall( NewCaseResult);

// Step 9. Bump fail count and exec count
if NewRunResult = erFail then
  SetFailCount( FFailCount + 1);
SetExecuteCount( FExecuteCount + 1);

// Step 10. Tell the client we are done.
SetStatus( sDone);
end;


function TTestCaseNode.InstrinsicExecutionCount: integer;
begin
result := FExecuteCount
end;

function TTestCaseNode.IntrinsicFailCount: integer;
begin
result := FFailCount
end;

function TTestCaseNode.IntrinsicLoadCount: integer;
begin
result := Length( FRuns)
end;

procedure TTestCaseNode.ActuateNobs;
begin
// TBD
end;

procedure TTestCaseNode.AutoFail(    // ***
  Reason: TAutoFailReason; InvocationPhase: TTestPointPhase; E: Exception);
var
  Harn: ITestHarnessEx;
begin
if Supports( FHarnessToUse, ITestHarnessEx, Harn) or (Reason = reasonFailMethod) then
  case Reason of
    reasonUserException: Harn.MarkFail( E.Message);
    reasonFailMethod   : ;    // Responding to UserFailException. Do nothing.
    reasonTimeOut      : Harn.MarkFail( TimeOutErrorMessage);
    reasonHang         : Harn.MarkFail( HangOutErrorMessage);
    reasonLeakage      : Harn.MarkFail( LeakageErrorMessage);
    end;
if assigned( Harn) and Harn.HasFailed and (Harn.FailMessage <> '') and
   assigned( FMaster) then
  FMaster.Failure( self as ITestCaseNode, Harn.FailMessage, Harn.FailStamp)
end;

procedure TTestCaseNode.AbsorbHarness;
var
  Source, Destin: ITestHarnessEx;
  Member: INonFailMessage;
begin
if (not Supports( FThreadedHarness, ITestHarnessEx, Source)) or
   (not Supports( FHarness        , ITestHarnessEx, Destin)) then exit;
if Source.HasFailed then
  Destin.MarkFail( Source.FailMessage, Source.FailStamp);
for Member in Source.NonFailMessages do
  Destin.AddNonFailMessage( Member);
FThreadedHarness := nil;
FHarnessToUse    := FHarness
end;

function TTestCaseNode.GetExecResult_Point: TExecutionResult;
begin
if CursorOutOfBounds then
    result := erFail
  else
    result := FRuns[FRunCursor.FRunIdx].FPoints[FRunCursor.FPhase].ExecutionResult
end;

function TTestCaseNode.GetFailMessage: string;
begin
result := (FHarness as ITestHarnessEx).FailMessage
end;

function TTestCaseNode.GetFailStamp: TDateTime;
begin
result := (FHarness as ITestHarnessEx).FailStamp
end;

function TTestCaseNode.GetNonFailMessages: TNonFailMessageArray;
begin
result := (FHarness as ITestHarnessEx).NonFailMessages
end;

function TTestCaseNode.GetRunCount: integer;
begin
result := Length( FRuns)
end;

function TTestCaseNode.GetStatus_Point: uSBDUnit_TestScheduler.TNodeStatus;
begin
if CursorOutOfBounds then
    result := nsNeutral
  else
    result := FRuns[FRunCursor.FRunIdx].FPoints[FRunCursor.FPhase].Status
end;

procedure TTestCaseNode.SetCursorMemento( const Memento: RTestPointCursorMemento);
begin
FRunCursor := Memento
end;

procedure TTestCaseNode.SetExecResult_Point( Value: TExecutionResult);
begin
if not CursorOutOfBounds then
  FRuns[FRunCursor.FRunIdx].FPoints[ FRunCursor.FPhase].ExecutionResult := Value
end;

function TTestCaseNode.RttiMethod( var NewContext: TRttiContext): TRttiMethod;
var
  MethodIndex: integer;
  M: TRttiMethod;
  s: string;
  HostCls: TClass;
begin
NewContext.Create;
MethodIndex := 0;
result := nil;
if Assigned( FParentSuite) then
    HostCls := FParentSuite.SuiteObject.ClassType
  else
    HostCls := nil;
if (not Assigned( HostCls)) or (FMethod = -1) then exit;
for M in NewContext.GetType( HostCls).GetDeclaredMethods do
  if (Length( M.GetParameters) = 0) and (M.MethodKind = mkProcedure) then
    begin
    s := M.Name;
    if FMethod = MethodIndex then
      begin
      result := M;
      break
      end;
    Inc( MethodIndex)
    end
end;


procedure TTestCaseNode.SetMethodIndex( MethodIdx: integer);
var
  Context: TRttiContext;
  M: TRttiMethod;
  sName: string;
begin
FMethod := MethodIdx;
try
  M := RttiMethod( Context);
  try
    sName := M.Name
  finally
    Context.Free
  end;
except
  sName := 'error'
  end;
(self as ITestNodeEx).SetName( sName);
TriggerModulationEvent( [evTestCaseConstruction]);
if FNobs.FRepeatCount < 1 then
  FNobs.FRepeatCount := 1;
SetLength( FRuns, FNobs.FRepeatCount);
FRunCursor.FRunCount := Length( FRuns);
ClearRuns;
FRunCursor.ResetCursor;
if assigned( FMaster) then
  FMaster.AddedNode( self as ITestNode)
end;


procedure TTestCaseNode.SetParentNodeAsIntf( const Value: IInterface);
begin
inherited;
Supports( Value, ITestSuiteNodeEx, FParentSuite)
end;

procedure TTestCaseNode.SetStatus_Point(
  Value: uSBDUnit_TestScheduler.TNodeStatus);
var
  GrossStatus: uSBDUnit_TestScheduler.TNodeStatus;
  j: integer;
  i: TTestPointPhase;
  GrossTestStatus: uSBDUnit_Types.TTestStatus;

  function PrevailanceOfStatus( Value: uSBDUnit_TestScheduler.TNodeStatus): integer;
  // Declared    order is nsNeutral, nsDoing, nsDone, nsSkipped.
  // Prevailance order is nsNeutral, nsSkipped, nsDoing, nsDone.
  begin
  case Value of
    nsNeutral: result := 0;
    nsDoing  : result := 2;
    nsDone   : result := 3;
    nsSkipped: result := 1;
    end
  end;

begin
if not CursorOutOfBounds then
  begin
  FRuns[FRunCursor.FRunIdx].FPoints[FRunCursor.FPhase].Status := Value;
  if (FRunCursor.FRunIdx >= (FRunCursor.FRunCount - 1)) and
     (FRunCursor.FPhase = High( TTestPointPhase)) and
     (FStatus in [sReady, sSkipped]) then
    begin
    GrossStatus := nsNeutral;
    for j := 0 to FRunCursor.FRunCount - 1 do
      for i := Low( TTestPointPhase) to High( TTestPointPhase) do
        if PrevailanceOfStatus( FRuns[j].FPoints[i].Status) > PrevailanceOfStatus( GrossStatus) then
          GrossStatus := FRuns[j].FPoints[i].Status;
    case GrossStatus of
      nsNeutral: GrossTestStatus := sReady;
      nsDoing  : GrossTestStatus := sTesting;
      nsDone   : GrossTestStatus := sDone;
      nsSkipped: GrossTestStatus := sSkipped;
      end;
    SetStatus( GrossTestStatus, 0.0)
    end
  end
end;


procedure TTestCaseNode.ShutDown;
var
  Harn: ITestHarnessEx;
begin
inherited;
FParentSuite := nil;
FThreadedHarness := nil;
SetLength( FRuns, 0);
if Supports( FHarness, ITestHarnessEx, Harn) then
  Harn.ShutDown;
FHarness := nil;
if Supports( FThreadedHarness, ITestHarnessEx, Harn) then
  Harn.ShutDown;
FThreadedHarness := nil;
FHarnessToUse := nil
end;

function TTestCaseNode.TimeOut: integer;
begin
result := FTimeOut
end;


procedure TTestCaseNode.TriggerModulationEvent( Events: TTestModulationEventSet);
var
  Rtti: TRttiContext;
  M: TRttiMethod;
  A: TCustomAttribute;
  Modulator: TTestModulator;
  Intersection: TTestModulationEventSet;
  Event: TTestModulationEvent;
  ModCount: integer;
begin
if Events = [] then exit;
ModCount := 0;
M := RttiMethod( Rtti);
for A in M.GetAttributes do
  begin
  if not (A is TTestModulator) then continue;
  Modulator := TTestModulator( A);
  Intersection := Modulator.InterestedIn * Events;
  for Event in Intersection do
    begin
    Modulator.ModulateTest( Event, FNobs);
    Inc( ModCount)
    end
  end;
Rtti.Free;
if ModCount > 0 then
  ActuateNobs
end;

{ RTestPoint }

procedure RTestPoint.Clear;
begin
Status          := nsNeutral;
ExecutionResult := erNull
end;

{ RCaseRun }

procedure RCaseRun.Clear;
var
  j: TTestPointPhase;
begin
FRunResult := erNull;
for j := Low( TTestPointPhase) to High( TTestPointPhase) do
  FPoints[j].Clear
end;

function RCaseRun.ComputeRunResult: TExecutionResult;
var
  Point: RTestPoint;
  PassCount: integer;
begin
result    := erNull;
PassCount := 0;
for Point in FPoints do
  case Point.ExecutionResult of
    erNull: ;
    erPass: Inc( PassCount);
    erFail: Exit( erFail);
    end;
if PassCount = Length( FPoints) then
  result := erPass
end;

procedure RCaseRun.SkipIfNotDone;
var
  ph: TTestPointPhase;
begin
for ph := Low( TTestPointPhase) to High( TTestPointPhase) do
  if not (FPoints[ph].Status in [nsDone, nsSkipped]) then
    FPoints[ph].Status := nsSkipped
end;

{ TNonFailMessage }

constructor TNonFailMessage.CreateInfo;
begin
FKind := mkInfo
end;

constructor TNonFailMessage.CreateWarning;
begin
FKind := mkWarning
end;

class function TNonFailMessage.ExceptionClass: TSBDUnit_ExceptionClass;
begin
result := TSBDUnit_TestCaseException
end;

function TNonFailMessage.Kind: TNonFailMessageKind;
begin
result := FKind
end;

function TNonFailMessage.Msg: string;
begin
result := FMsg
end;

procedure TNonFailMessage.SetNonFailMessage(
  Stamp1: TDateTime; const Msg1: string);
begin
FStamp := Stamp1;
FMsg   := Msg1
end;

function TNonFailMessage.Stamp: TDateTime;
begin
result := FStamp
end;



end.
